################################################################################################################################################################
##########   Description: Application 1 related to Micropropagation of columnar apple trees dataset   ##########   
################################################################################################################################################################

require(agridat)
require(ridout.appleshoots)
require(polyaAeppli)

 attach(ridout.appleshoots)
 y = roots
 x1 <- factor(photo)
 x2 <- factor(bap)


############################ Poisson-model #####################################

###################
#### With interaction
###################

fit.model <- glm(y ~ x1*x2, family = poisson)
summary(fit.model)

 -2*logLik(fit.model)
AIC(fit.model)
BIC(fit.model)


CAIC  = -2*logLik(fit.model)[1] +  dim(model.matrix(fit.model))[2]*(log(length(y))+ 1)
CAIC

###################
#### Only with the covariate x1
###################

fit.model <- glm(y ~ x1, family = poisson)
summary(fit.model)

 -2*logLik(fit.model)
AIC(fit.model)
BIC(fit.model)


CAIC  = -2*logLik(fit.model)[1] +  dim(model.matrix(fit.model))[2]*(log(length(y))+ 1)
CAIC

############################ NB-model ##########################################

###################
#### With interaction
###################

require(MASS)
fit.model <- glm.nb(y ~ x1*x2)
summary(fit.model)

 -2*logLik(fit.model)
AIC(fit.model)
BIC(fit.model)


CAIC  = -2*logLik(fit.model)[1] +  (dim(model.matrix(fit.model))[2] + 1)*(log(length(y))+ 1)
CAIC

###################
#### Only with the covariate x1
###################

fit.model <- glm.nb(y ~ x1)
summary(fit.model)

 -2*logLik(fit.model)
AIC(fit.model)
BIC(fit.model)


CAIC  = -2*logLik(fit.model)[1] +  (dim(model.matrix(fit.model))[2] + 1)*(log(length(y))+ 1)
CAIC

############################ ZIP-model #########################################

###################
#### With interaction
###################

require(pscl)
fit.model <- zeroinfl(y ~ x1*x2 | 1)
summary(fit.model)

 -2*logLik(fit.model)
AIC(fit.model)

BIC  = -2*logLik(fit.model)[1] +  (dim(model.matrix(fit.model))[2] + 1)*log(length(y))
BIC

CAIC  = -2*logLik(fit.model)[1] +  (dim(model.matrix(fit.model))[2] + 1)*(log(length(y))+ 1)
CAIC

###################
#### Only with the covariate x1
###################

fit.model <- zeroinfl(y ~ x1 | 1)
summary(fit.model)

 -2*logLik(fit.model)
AIC(fit.model)

BIC  = -2*logLik(fit.model)[1] +  (dim(model.matrix(fit.model))[2] + 1)*log(length(y))
BIC

CAIC  = -2*logLik(fit.model)[1] +  (dim(model.matrix(fit.model))[2] + 1)*(log(length(y))+ 1)
CAIC




############################ ZINB-model######################################

###################
#### With interaction
###################

require(pscl)
fit.model <- zeroinfl(y ~ x1*x2 | 1, dist = "negbin")

summary(fit.model)

 -2*logLik(fit.model)
AIC(fit.model)

BIC  = -2*logLik(fit.model)[1] +  (dim(model.matrix(fit.model))[2] + 2)*log(length(y))
BIC

CAIC  = -2*logLik(fit.model)[1] +  (dim(model.matrix(fit.model))[2] + 2)*(log(length(y))+ 1)
CAIC

###################
#### Only with the covariate x1
###################

fit.model <- zeroinfl(y ~ x1 | 1, dist = "negbin")
summary(fit.model)

 -2*logLik(fit.model)
AIC(fit.model)

BIC  = -2*logLik(fit.model)[1] +  (dim(model.matrix(fit.model))[2] + 2)*log(length(y))
BIC

CAIC  = -2*logLik(fit.model)[1] +  (dim(model.matrix(fit.model))[2] + 2)*(log(length(y))+ 1)
CAIC

############################ PA-model ##########################################

###################
#### Only with the covariate x1
###################

Xe     = model.matrix(~ x1)

f = function(theta1) {
  
  betae  = theta1[1:2]
  rho    = 1/(1+exp(-theta1[3]))
 
  mu     = exp(Xe %*% betae)

  lambda = mu*(1-rho)	
 
  loglik = dPolyaAeppli(y, lambda, rho, log = TRUE)

  sum(loglik)
}

theta0 = rep(0.1,3)
m.IP   = optim(theta0, f, control = list(fnscale = -1, trace = FALSE, maxit = 10000),  method = "L-BFGS-B")

AIC    = -2 * m.IP$value + 2 * length(m.IP$par)
BIC    = -2 * m.IP$value + length(m.IP$par) * log(length(y))
CAIC = -2 * m.IP$value + length(m.IP$par)*(log(length(y)) + 1)
cbind(c("AIC","BIC", "CAIC"),round(c(AIC,BIC, CAIC), 3))

Loglike_x1 <- m.IP$value
Loglike_x1
-2*Loglike_x1

###################
#### with interaction
###################

Xe     = model.matrix(~ x1*x2)

f = function(theta1) {
  
  betae  = theta1[1:8]
  rho    = 1/(1+exp(-theta1[9]))

  mu     = exp(Xe %*% betae)

  lambda = mu*(1-rho)	
 
  loglik = dPolyaAeppli(y, lambda, rho, log = TRUE)

  sum(loglik)
}

theta0 = rep(0.1,9)
m.IP   = optim(theta0, f, control = list(fnscale = -1, trace = FALSE, maxit = 10000),  method = "L-BFGS-B", hessian = TRUE)

AIC    = -2 * m.IP$value + 2 * length(m.IP$par)
BIC    = -2 * m.IP$value + length(m.IP$par) * log(length(y))
CAIC = -2 * m.IP$value + length(m.IP$par)*(log(length(y)) + 1)
cbind(c("AIC","BIC", "CAIC"),round(c(AIC,BIC, CAIC), 3))

Loglike_int <- m.IP$value
Loglike_int
-2*Loglike_int

###################
##### Likelihood ratio test between the PA-models presented previously
###################

DD= -2*(Loglike_x1-Loglike_int)
P_value = 1-pchisq(DD, dim(model.matrix(~x1*x2))[2]-dim(model.matrix(~x1))[2])
P_value

######################################################
######################################################
##### Predictive measures (Table 3). The following R code for the analyses of Table 3 was adapted from Supplementary Materials of Czado, C., Gneiting, T., and Held, L. (2009).
##### Czado, C., Gneiting, T., and Held, L. (2009). Predictive model assessment for count data. Biometrics, 65, 1254-1261. Supplementary materials are avaliable at ##### http://www.biometrics.tibs.org. (Acessed on 10/10/2016).
######################################################
######################################################

n <- length(roots)

#################################
################## Roots by Photo
#################################

### count regressions in cross validation mode 

### Poisson regression 

p.pois.lambda <- rep(0,n)
p.pois.Px <- rep(0,n) 
p.pois.Px1 <- rep(0,n)
p.pois.px <- rep(0,n) 

for (i in 1:n)
  {
  temp <- glm(roots[-i] ~ photo[-i], family=poisson)
  beta <- coef(temp)
  p.pois.lambda[i] <- exp(t(beta)%*%c(1,photo[i]))
  p.pois.Px[i] <- ppois(roots[i],p.pois.lambda[i])
  p.pois.Px1[i] <- ppois(roots[i]-1,p.pois.lambda[i])
  p.pois.px[i] <- dpois(roots[i],p.pois.lambda[i])
  }

### negative binomial regression 

p.nb.lambda <- rep(0,n)
p.nb.theta <- rep(0,n)
p.nb.Px <- rep(0,n)
p.nb.Px1 <- rep(0,n)
p.nb.px <- rep(0,n) 
 
library(MASS)    

for (i in 1:n)
  {
  temp <- glm.nb(roots[-i] ~ photo[-i])
  beta <- coef(temp)
  p.nb.lambda[i] <- exp(t(beta)%*%c(1,photo[i]))
  p.nb.theta[i] <- temp$theta
  p.nb.Px[i] <- pnbinom(roots[i],size=p.nb.theta[i],mu=p.nb.lambda[i])
  p.nb.Px1[i] <- pnbinom(roots[i]-1,size=p.nb.theta[i],mu=p.nb.lambda[i])
  p.nb.px[i] <- dnbinom(roots[i],size=p.nb.theta[i],mu=p.nb.lambda[i])
  }

### inflated poisson regression 

p.zip.lambda <- rep(0,n)
p.zip.theta <- rep(0,n)
p.zip.Px <- rep(0,n)
p.zip.px <- rep(0,n) 
 
require(gamlss)    
require(pscl) 

temp.zip_c <- zeroinfl(roots ~ photo | 1)
ls <- dim(model.matrix(temp.zip_c))[2]

for (i in 1:n)
  {
  temp <- zeroinfl(roots[-i] ~ photo[-i] | 1)
  beta <- coef(temp)[1:ls]
  p.zip.lambda[i] <- exp(t(beta)%*%c(1,photo[i]))
  p.zip.theta[i] <- as.numeric((exp(-coef(temp)[ls+1])+1)^(-1))
  p.zip.Px[i] <- pZIP2(roots[i],sigma=p.zip.theta[i],mu=p.zip.lambda[i])
  p.zip.px[i] <- dZIP2(roots[i],sigma=p.zip.theta[i],mu=p.zip.lambda[i])
  }

### inflated negative regression 

p.zinb.lambda <- rep(0,n)
p.zinb.theta <- rep(0,n)
p.zinb.omega <- rep(0,n)
p.zinb.Px <- rep(0,n)
p.zinb.px <- rep(0,n) 

require(VGAM)    
require(pscl) 

temp.zinb_c <- zeroinfl(roots ~ photo | 1, dist = "negbin")
ls <- dim(model.matrix(temp.zinb_c))[2]

for (i in 1:n)
  {
  temp <- zeroinfl(roots[-i] ~ photo[-i] | 1, dist = "negbin")
  beta <- coef(temp)[1:ls]
  p.zinb.lambda[i] <- exp(t(beta)%*%c(1,photo[i]))
  p.zinb.theta[i] <- temp$theta
  p.zinb.omega[i] <-  as.numeric((exp(-coef(temp)[ls+1])+1)^(-1))
  p.zinb.Px[i] <- pzinegbin(roots[i],size=p.zinb.theta[i],munb=p.zinb.lambda[i]/(1-p.zinb.omega[i]), pstr0 = p.zinb.omega[i])
  p.zinb.px[i] <- dzinegbin(roots[i],size=p.zinb.theta[i],munb=p.zinb.lambda[i]/(1-p.zinb.omega[i]), pstr0 = p.zinb.omega[i])
  }

### PA regression

p.pa.lambda <- rep(0,n)
p.pa.rho <- rep(0,n)
p.pa.Px <- rep(0,n)
p.pa.px <- rep(0,n) 

 y = roots
 x1 <- factor(photo)
 x2 <- factor(bap)

 Xe     = model.matrix(~ x1)

require(polyaAeppli)  # package of Plya-Aeppli distribution

for (i in 1:n){

  	f = function(theta1) {
		betae  = theta1[1:dim(Xe)[2]]
  		rho    = 1/(1+exp(-theta1[dim(Xe)[2]+1]))
 		mu     = exp(Xe[-i,] %*% betae)
		lambda = mu*(1-rho)	
 		loglik = dPolyaAeppli(y[-i], lambda, rho, log = TRUE)
 	 	sum(loglik)
	}

theta0 = rep(0.1,dim(Xe)[2]+1)
m.IP   = optim(theta0, f, control = list(fnscale = -1, trace = FALSE, maxit = 10000),  method = "L-BFGS-B")

beta <- m.IP$par[1:dim(Xe)[2]]
p.pa.lambda[i] <- exp(Xe[i,] %*% beta)
p.pa.rho[i] <-  1/(1+exp(-m.IP$par[dim(Xe)[2]+1]))
p.pa.Px[i] <- pPolyaAeppli(y[i], p.pa.lambda[i]*(1-p.pa.rho[i]), p.pa.rho[i])
p.pa.px[i] <- dPolyaAeppli(y[i], p.pa.lambda[i]*(1-p.pa.rho[i]), p.pa.rho[i])
}

### parameter settings for computing scores

kk <- 100000                            ### cut-off for summations 
my.k <- (0:kk)                          ### to handle ranked probability score

##################
### compute scores
##################

### Poisson regression 

p.pois.logs <- - log(p.pois.px) 
  p.pois.norm <- 1:n
  for (i in 1:n) {p.pois.norm[i] <- sum(dpois(my.k,p.pois.lambda[i])^2)} 
p.pois.qs <- - 2*p.pois.px + p.pois.norm
p.pois.sphs <- - p.pois.px / sqrt(p.pois.norm)
p.pois.rps <- 1:n 
  for (i in 1:n) 
    {p.pois.rps[i] <- sum(ppois((-1):(roots[i]-1),p.pois.lambda[i])^2) + sum((ppois(roots[i]:kk,p.pois.lambda[i])-1)^2)}
p.pois.dss <- (roots-p.pois.lambda)^2/p.pois.lambda + 2*log(sqrt(p.pois.lambda))
p.pois.ses <- (roots-p.pois.lambda)^2

### Negative binomial regression 

p.nb.px <- dnbinom(roots,mu=p.nb.lambda,size=p.nb.theta)
p.nb.logs <- - log(p.nb.px)
  p.nb.norm <- 1:n
  for (i in 1:n) 
    {p.nb.norm[i] <- sum(dnbinom(my.k,mu=p.nb.lambda[i],size=p.nb.theta[i])^2)} 
p.nb.qs <- - 2*p.nb.px + p.nb.norm
p.nb.sphs <- - p.nb.px / sqrt(p.nb.norm)
p.nb.rps <- 1:n 
  for (i in 1:n) 
    {
    p.nb.rps[i] <- sum(pnbinom((-1):(roots[i]-1),mu=p.nb.lambda[i],size=p.nb.theta[i])^2) 
    p.nb.rps[i] <- p.nb.rps[i] + sum((pnbinom(roots[i]:kk,mu=p.nb.lambda[i],size=p.nb.theta[i])-1)^2)
    }
p.nb.dss <- (roots-p.nb.lambda)^2/(p.nb.lambda*(1+p.nb.lambda/p.nb.theta)) + 2*log(sqrt(p.nb.lambda*(1+p.nb.lambda/p.nb.theta)))
p.nb.ses <- (roots-p.nb.lambda)^2

### Inflated poisson regression 

 pZIP2_meu <- function (q, mu, sigma, lower.tail = TRUE, log.p = FALSE) 
{
    if (any(mu <= 0)) 
        stop(paste("mu must be greater than 0", "\n", ""))
    if (any(sigma <= 0) | any(sigma >= 1)) 
        stop(paste("sigma must be between 0 and 1", "\n", ""))
    if (any(q >= -1)){ 
        mus <- mu/(1 - sigma)
    	  cdf <- rep(0, length(q))
        cdf <- ppois(q, lambda = mus, lower.tail = TRUE, log.p = FALSE)
        cdf <- sigma + (1 - sigma) * cdf}
     if (any(q < 0)) 
     cdf <- 0
    if (lower.tail == TRUE) 
        cdf <- cdf
    else cdf <- 1 - cdf
    if (log.p == FALSE) 
        cdf <- cdf
    else cdf <- log(cdf)
    cdf
}


p.zip.rps <- numeric()
 for (i in 1:n) {
       aux_1 <- numeric()
 	 aux_1 <- (-1):(roots[i]-1)
                aux_2 <- numeric()
                aux_2 <- roots[i]:kk
   aux_3 <- numeric()
   for(j in 1:length(aux_1)){
         aux_3[j] <- pZIP2_meu(aux_1[j],mu=p.zip.lambda[i],sigma=p.zip.theta[i])
   }
 aux_4 <- numeric()
 for(j in 1:length(aux_2)){
         aux_4[j] <- pZIP2_meu(aux_2[j],mu=p.zip.lambda[i],sigma=p.zip.theta[i])-1
  } 
   p.zip.rps[i] <- sum(aux_3^2)
   p.zip.rps[i] <- p.zip.rps[i] + sum((aux_4)^2)
   aux_3 <- numeric()
   aux_4 <- numeric()
 }

p.zip.px <- dZIP2(roots,mu=p.zip.lambda,sigma=p.zip.theta)
p.zip.logs <- - log(p.zip.px)
  p.zip.norm <- 1:n
  for (i in 1:n) 
    {p.zip.norm[i] <- sum(dZIP2(my.k,mu=p.zip.lambda[i],sigma=p.zip.theta[i])^2)} 
p.zip.qs <- - 2*p.zip.px + p.zip.norm
p.zip.sphs <- - p.zip.px / sqrt(p.zip.norm)
p.zip.dss <- (roots-p.zip.lambda)^2/(p.zip.lambda*(1+p.zip.lambda/(1/p.zip.theta-1))) + 2*log(sqrt((p.zip.lambda*(1+p.zip.lambda/(1/p.zip.theta-1)))))
p.zip.ses <- (roots-p.zip.lambda)^2


### Inflated negative binomial regression 

p.zinb.px <- dzinegbin(roots,size=p.zinb.theta,munb=p.zinb.lambda/(1-p.zinb.omega), pstr0 = p.zinb.omega) 
p.zinb.logs <- - log(p.zinb.px)
  p.zinb.norm <- 1:n
  for (i in 1:n) 
    {p.zinb.norm[i] <- sum(dzinegbin(my.k,munb=p.zinb.lambda[i]/(1-p.zinb.omega[i]),size=p.zinb.theta[i], pstr0 = p.zinb.omega[i])^2)} 
p.zinb.qs <- - 2*p.zinb.px + p.zinb.norm
p.zinb.sphs <- - p.zinb.px / sqrt(p.zinb.norm)
p.zinb.rps <- 1:n 
  for (i in 1:n) 
    {
    p.zinb.rps[i] <- sum(pzinegbin((-1):(roots[i]-1),munb=p.zinb.lambda[i]/(1-p.zinb.omega[i]), size=p.zinb.theta[i], pstr0 = p.zinb.omega[i])^2) 
    p.zinb.rps[i] <- p.zinb.rps[i] + sum((pzinegbin(roots[i]:kk,munb=p.zinb.lambda[i]/(1-p.zinb.omega[i]),size=p.zinb.theta[i],  pstr0 = p.zinb.omega[i])-1)^2)
    }
p.zinb.dss <- (roots-p.zinb.lambda)^2/(p.zinb.lambda*(1+(p.zinb.lambda/(1-p.zinb.theta)))*(p.zinb.theta+p.zinb.omega)) + 2*log(sqrt((p.zinb.lambda*(1+(p.zinb.lambda/(1-p.zinb.theta)))*(p.zinb.theta+p.zinb.omega))))
p.zinb.ses <- (roots-p.zinb.lambda)^2

### Polya-Aeppli regression 

p.pa.px <- dPolyaAeppli(roots, p.pa.lambda*(1-p.pa.rho), p.pa.rho) 
p.pa.logs <- - log(p.pa.px)
  p.pa.norm <- 1:n
  for (i in 1:n) 
    {p.pa.norm[i] <- sum(dPolyaAeppli(my.k, p.pa.lambda[i]*(1-p.pa.rho[i]), p.pa.rho[i])^2)} 
p.pa.qs <- - 2*p.pa.px + p.pa.norm
p.pa.sphs <- - p.pa.px / sqrt(p.pa.norm)
p.pa.rps <- 1:n 
  for (i in 1:n) 
    {
    p.pa.rps[i] <- sum(pPolyaAeppli((-1):(roots[i]-1), p.pa.lambda[i]*(1-p.pa.rho[i]), p.pa.rho[i])^2) 
    p.pa.rps[i] <- p.pa.rps[i] + sum((pPolyaAeppli(roots[i]:kk, p.pa.lambda[i]*(1-p.pa.rho[i]), p.pa.rho[i])-1)^2)
    }
p.pa.dss <- (roots-p.pa.lambda)^2/(p.pa.lambda*((1+p.pa.rho)/(1-p.pa.rho))) + 2*log(sqrt(p.pa.lambda*((1+p.pa.rho)/(1-p.pa.rho))))
p.pa.ses <- (roots-p.pa.lambda)^2


### reproduce Table 3 column by column - Photo

round(c(mean(p.pois.logs),mean(p.nb.logs), mean(p.zip.logs), mean(p.zinb.logs), mean(p.pa.logs)), 2)    ### logarithmic score
round(c(mean(p.pois.qs),mean(p.nb.qs), mean(p.zip.qs), mean(p.zinb.qs), mean(p.pa.qs)), 2)              ### quadratic score
round(c(mean(p.pois.sphs),mean(p.nb.sphs),mean(p.zip.sphs), mean(p.zinb.sphs), mean(p.pa.sphs)),2)      ### spherical score  
round(c(mean(p.pois.rps),mean(p.nb.rps),mean(p.zip.rps),mean(p.zinb.rps), mean(p.pa.rps)),2)            ### ranked probability score
round(c(mean(p.pois.dss),mean(p.nb.dss),mean(p.zip.dss),mean(p.zinb.dss), mean(p.pa.dss)),2)            ### Dawid-Sebastiani score
round(c(mean(p.pois.ses),mean(p.nb.ses),mean(p.zip.ses),mean(p.zinb.ses), mean(p.pa.ses)), 2)           ### squared error score   

#########################################
################## Roots by Photo and Bap
#########################################

### count regressions in cross validation mode 

### Poisson regression 

p.pois.lambda <- rep(0,n)
p.pois.Px <- rep(0,n) 
p.pois.Px1 <- rep(0,n)
p.pois.px <- rep(0,n) 

for (i in 1:n)
  {
  temp <- glm(roots[-i] ~ photo[-i]*bap[-i], family=poisson)
  beta <- coef(temp)
  p.pois.lambda[i] <- exp(t(beta)%*%c(1,photo[i], bap[i], photo[i]*bap[i]))
  p.pois.Px[i] <- ppois(roots[i],p.pois.lambda[i])
  p.pois.Px1[i] <- ppois(roots[i]-1,p.pois.lambda[i])
  p.pois.px[i] <- dpois(roots[i],p.pois.lambda[i])
  }

### negative binomial regression 

p.nb.lambda <- rep(0,n)
p.nb.theta <- rep(0,n)
p.nb.Px <- rep(0,n)
p.nb.Px1 <- rep(0,n)
p.nb.px <- rep(0,n) 
 
library(MASS)    

for (i in 1:n)
  {
  temp <- glm.nb(roots[-i] ~ photo[-i]*bap[-i])
  beta <- coef(temp)
  p.nb.lambda[i] <- exp(t(beta)%*%c(1,photo[i], bap[i], photo[i]*bap[i]))
  p.nb.theta[i] <- temp$theta
  p.nb.Px[i] <- pnbinom(roots[i],size=p.nb.theta[i],mu=p.nb.lambda[i])
  p.nb.Px1[i] <- pnbinom(roots[i]-1,size=p.nb.theta[i],mu=p.nb.lambda[i])
  p.nb.px[i] <- dnbinom(roots[i],size=p.nb.theta[i],mu=p.nb.lambda[i])
  }

### inflated poisson regression 

p.zip.lambda <- rep(0,n)
p.zip.theta <- rep(0,n)
p.zip.Px <- rep(0,n)
p.zip.px <- rep(0,n) 
 
require(gamlss)    
require(pscl) 

temp.zip_c <- zeroinfl(roots ~ photo*bap | 1)
ls <- dim(model.matrix(temp.zip_c))[2]

for (i in 1:n)
  {
  temp <- zeroinfl(roots[-i] ~ photo[-i]*bap[-i] | 1)
  beta <- coef(temp)[1:ls]
  p.zip.lambda[i] <- exp(t(beta)%*%c(1,photo[i], bap[i], photo[i]*bap[i]))
  p.zip.theta[i] <- as.numeric((exp(-coef(temp)[ls+1])+1)^(-1))
  p.zip.Px[i] <- pZIP2(roots[i],sigma=p.zip.theta[i],mu=p.zip.lambda[i])
  p.zip.px[i] <- dZIP2(roots[i],sigma=p.zip.theta[i],mu=p.zip.lambda[i])
  }

### inflated negative regression 

p.zinb.lambda <- rep(0,n)
p.zinb.theta <- rep(0,n)
p.zinb.omega <- rep(0,n)
p.zinb.Px <- rep(0,n)
p.zinb.px <- rep(0,n) 

require(VGAM)    
require(pscl) 

temp.zinb_c <- zeroinfl(roots ~ photo*bap | 1, dist = "negbin")
ls <- dim(model.matrix(temp.zinb_c))[2]

for (i in 1:n)
  {
  temp <- zeroinfl(roots[-i] ~ photo[-i]*bap[-i] | 1, dist = "negbin")     # ou escreve-se zeroinfl(roots[-i] ~ photo*bap | 1, dist = "negbin", data = apple[-i,])
  beta <- coef(temp)[1:ls]
  p.zinb.lambda[i] <- exp(t(beta)%*%c(1,photo[i], bap[i], photo[i]*bap[i]))
  p.zinb.theta[i] <- temp$theta
  p.zinb.omega[i] <-  as.numeric((exp(-coef(temp)[ls+1])+1)^(-1))
  p.zinb.Px[i] <- pzinegbin(roots[i],size=p.zinb.theta[i],munb=p.zinb.lambda[i]/(1-p.zinb.omega[i]), pstr0 = p.zinb.omega[i])
  p.zinb.px[i] <- dzinegbin(roots[i],size=p.zinb.theta[i],munb=p.zinb.lambda[i]/(1-p.zinb.omega[i]), pstr0 = p.zinb.omega[i])
  }

### PA regression

p.pa.lambda <- rep(0,n)
p.pa.rho <- rep(0,n)
p.pa.Px <- rep(0,n)
p.pa.px <- rep(0,n) 

 y = roots
 x1 <- factor(photo)
 x2 <- factor(bap)

 Xe     = model.matrix(~ x1*x2)

require(polyaAeppli)  # package of Plya-Aeppli distribution

for (i in 1:n){

  	f = function(theta1) {
		betae  = theta1[1:dim(Xe)[2]]
  		rho    = 1/(1+exp(-theta1[dim(Xe)[2]+1]))
 		mu     = exp(Xe[-i,] %*% betae)
		lambda = mu*(1-rho)	
 		loglik = dPolyaAeppli(y[-i], lambda, rho, log = TRUE)
 	 	sum(loglik)
	}

theta0 = rep(0.1,dim(Xe)[2]+1)
m.IP   = optim(theta0, f, control = list(fnscale = -1, trace = FALSE, maxit = 10000),  method = "L-BFGS-B")

beta <- m.IP$par[1:dim(Xe)[2]]
p.pa.lambda[i] <- exp(Xe[i,] %*% beta)
p.pa.rho[i] <-  1/(1+exp(-m.IP$par[dim(Xe)[2]+1]))
p.pa.Px[i] <- pPolyaAeppli(y[i], p.pa.lambda[i]*(1-p.pa.rho[i]), p.pa.rho[i])
p.pa.px[i] <- dPolyaAeppli(y[i], p.pa.lambda[i]*(1-p.pa.rho[i]), p.pa.rho[i])
}

### parameter settings for computing scores

kk <- 100000                            ### cut-off for summations 
my.k <- (0:kk)                          ### to handle ranked probability score

##################
### compute scores
##################

### Poisson regression 

p.pois.logs <- - log(p.pois.px) 
  p.pois.norm <- 1:n
  for (i in 1:n) {p.pois.norm[i] <- sum(dpois(my.k,p.pois.lambda[i])^2)} 
p.pois.qs <- - 2*p.pois.px + p.pois.norm
p.pois.sphs <- - p.pois.px / sqrt(p.pois.norm)
p.pois.rps <- 1:n 
  for (i in 1:n) 
    {p.pois.rps[i] <- sum(ppois((-1):(roots[i]-1),p.pois.lambda[i])^2) + sum((ppois(roots[i]:kk,p.pois.lambda[i])-1)^2)}
p.pois.dss <- (roots-p.pois.lambda)^2/p.pois.lambda + 2*log(sqrt(p.pois.lambda))
p.pois.ses <- (roots-p.pois.lambda)^2

### Negative binomial regression 

p.nb.px <- dnbinom(roots,mu=p.nb.lambda,size=p.nb.theta)
p.nb.logs <- - log(p.nb.px)
  p.nb.norm <- 1:n
  for (i in 1:n) 
    {p.nb.norm[i] <- sum(dnbinom(my.k,mu=p.nb.lambda[i],size=p.nb.theta[i])^2)} 
p.nb.qs <- - 2*p.nb.px + p.nb.norm
p.nb.sphs <- - p.nb.px / sqrt(p.nb.norm)
p.nb.rps <- 1:n 
  for (i in 1:n) 
    {
    p.nb.rps[i] <- sum(pnbinom((-1):(roots[i]-1),mu=p.nb.lambda[i],size=p.nb.theta[i])^2) 
    p.nb.rps[i] <- p.nb.rps[i] + sum((pnbinom(roots[i]:kk,mu=p.nb.lambda[i],size=p.nb.theta[i])-1)^2)
    }
p.nb.dss <- (roots-p.nb.lambda)^2/(p.nb.lambda*(1+p.nb.lambda/p.nb.theta)) + 2*log(sqrt(p.nb.lambda*(1+p.nb.lambda/p.nb.theta)))
p.nb.ses <- (roots-p.nb.lambda)^2

### Inflated poisson regression 

 pZIP2_meu <- function (q, mu, sigma, lower.tail = TRUE, log.p = FALSE) 
{
    if (any(mu <= 0)) 
        stop(paste("mu must be greater than 0", "\n", ""))
    if (any(sigma <= 0) | any(sigma >= 1)) 
        stop(paste("sigma must be between 0 and 1", "\n", ""))
    if (any(q >= -1)){ 
        mus <- mu/(1 - sigma)
    	  cdf <- rep(0, length(q))
        cdf <- ppois(q, lambda = mus, lower.tail = TRUE, log.p = FALSE)
        cdf <- sigma + (1 - sigma) * cdf}
     if (any(q < 0)) 
     cdf <- 0
    if (lower.tail == TRUE) 
        cdf <- cdf
    else cdf <- 1 - cdf
    if (log.p == FALSE) 
        cdf <- cdf
    else cdf <- log(cdf)
    cdf
}

p.zip.rps <- numeric()
 for (i in 1:n) {
       aux_1 <- numeric()
 	 aux_1 <- (-1):(roots[i]-1)
                aux_2 <- numeric()
                aux_2 <- roots[i]:kk
   aux_3 <- numeric()
   for(j in 1:length(aux_1)){
         aux_3[j] <- pZIP2_meu(aux_1[j],mu=p.zip.lambda[i],sigma=p.zip.theta[i])
   }
 aux_4 <- numeric()
 for(j in 1:length(aux_2)){
         aux_4[j] <- pZIP2_meu(aux_2[j],mu=p.zip.lambda[i],sigma=p.zip.theta[i])-1
  } 
   p.zip.rps[i] <- sum(aux_3^2)
   p.zip.rps[i] <- p.zip.rps[i] + sum((aux_4)^2)
 }

p.zip.px <- dZIP2(roots,mu=p.zip.lambda,sigma=p.zip.theta)
p.zip.logs <- - log(p.zip.px)
  p.zip.norm <- 1:n
  for (i in 1:n) 
    {p.zip.norm[i] <- sum(dZIP2(my.k,mu=p.zip.lambda[i],sigma=p.zip.theta[i])^2)} 
p.zip.qs <- - 2*p.zip.px + p.zip.norm
p.zip.sphs <- - p.zip.px / sqrt(p.zip.norm)
p.zip.dss <- (roots-p.zip.lambda)^2/(p.zip.lambda*(1+p.zip.lambda/(1/p.zip.theta-1))) + 2*log(sqrt((p.zip.lambda*(1+p.zip.lambda/(1/p.zip.theta-1)))))
p.zip.ses <- (roots-p.zip.lambda)^2


### Inflated negative binomial regression 

p.zinb.px <- dzinegbin(roots,size=p.zinb.theta,munb=p.zinb.lambda/(1-p.zinb.omega), pstr0 = p.zinb.omega) 
p.zinb.logs <- - log(p.zinb.px)
  p.zinb.norm <- 1:n
  for (i in 1:n) 
    {p.zinb.norm[i] <- sum(dzinegbin(my.k,munb=p.zinb.lambda[i]/(1-p.zinb.omega[i]),size=p.zinb.theta[i], pstr0 = p.zinb.omega[i])^2)} 
p.zinb.qs <- - 2*p.zinb.px + p.zinb.norm
p.zinb.sphs <- - p.zinb.px / sqrt(p.zinb.norm)
p.zinb.rps <- 1:n 
  for (i in 1:n) 
    {
    p.zinb.rps[i] <- sum(pzinegbin((-1):(roots[i]-1),munb=p.zinb.lambda[i]/(1-p.zinb.omega[i]), size=p.zinb.theta[i], pstr0 = p.zinb.omega[i])^2) 
    p.zinb.rps[i] <- p.zinb.rps[i] + sum((pzinegbin(roots[i]:kk,munb=p.zinb.lambda[i]/(1-p.zinb.omega[i]),size=p.zinb.theta[i],  pstr0 = p.zinb.omega[i])-1)^2)
    }
p.zinb.dss <- (roots-p.zinb.lambda)^2/(p.zinb.lambda*(1+(p.zinb.lambda/(1-p.zinb.theta)))*(p.zinb.theta+p.zinb.omega)) + 2*log(sqrt((p.zinb.lambda*(1+(p.zinb.lambda/(1-p.zinb.theta)))*(p.zinb.theta+p.zinb.omega))))
p.zinb.ses <- (roots-p.zinb.lambda)^2

### Polya-Aeppli regression 

p.pa.px <- dPolyaAeppli(roots, p.pa.lambda*(1-p.pa.rho), p.pa.rho) 
p.pa.logs <- - log(p.pa.px)
  p.pa.norm <- 1:n
  for (i in 1:n) 
    {p.pa.norm[i] <- sum(dPolyaAeppli(my.k, p.pa.lambda[i]*(1-p.pa.rho[i]), p.pa.rho[i])^2)} 
p.pa.qs <- - 2*p.pa.px + p.pa.norm
p.pa.sphs <- - p.pa.px / sqrt(p.pa.norm)
p.pa.rps <- 1:n 
  for (i in 1:n) 
    {
    p.pa.rps[i] <- sum(pPolyaAeppli((-1):(roots[i]-1), p.pa.lambda[i]*(1-p.pa.rho[i]), p.pa.rho[i])^2) 
    p.pa.rps[i] <- p.pa.rps[i] + sum((pPolyaAeppli(roots[i]:kk, p.pa.lambda[i]*(1-p.pa.rho[i]), p.pa.rho[i])-1)^2)
    }
p.pa.dss <- (roots-p.pa.lambda)^2/(p.pa.lambda*((1+p.pa.rho)/(1-p.pa.rho))) + 2*log(sqrt(p.pa.lambda*((1+p.pa.rho)/(1-p.pa.rho))))
p.pa.ses <- (roots-p.pa.lambda)^2

### reproduce Table 3 column by column - Photo and Bap

round(c(mean(p.pois.logs),mean(p.nb.logs), mean(p.zip.logs), mean(p.zinb.logs), mean(p.pa.logs)), 2)       ### logarithmic score
round(c(mean(p.pois.qs),mean(p.nb.qs), mean(p.zip.qs), mean(p.zinb.qs), mean(p.pa.qs)), 2)                 ### quadratic score
round(c(mean(p.pois.sphs),mean(p.nb.sphs),mean(p.zip.sphs), mean(p.zinb.sphs), mean(p.pa.sphs)),2)         ### spherical score  
round(c(mean(p.pois.rps),mean(p.nb.rps),mean(p.zip.rps),mean(p.zinb.rps), mean(p.pa.rps)),2)               ### ranked probability score
round(c(mean(p.pois.dss),mean(p.nb.dss),mean(p.zip.dss),mean(p.zinb.dss), mean(p.pa.dss)),2)               ### Dawid-Sebastiani score
round(c(mean(p.pois.ses),mean(p.nb.ses),mean(p.zip.ses),mean(p.zinb.ses), mean(p.pa.ses)), 2)              ### squared error score   













